home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / mops / tinyexam.scm < prev   
Text File  |  1993-07-23  |  10KB  |  362 lines
  1. ; Mode: Scheme
  2. ;
  3. ;
  4. ; **********************************************************************
  5. ; Copyright (c) 1992 Xerox Corporation.  
  6. ; All Rights Reserved.  
  7. ;
  8. ; Use, reproduction, and preparation of derivative works are permitted.
  9. ; Any copy of this software or of any derivative work must include the
  10. ; above copyright notice of Xerox Corporation, this paragraph and the
  11. ; one after it.  Any distribution of this software or derivative works
  12. ; must comply with all applicable United States export control laws.
  13. ;
  14. ; This software is made available AS IS, and XEROX CORPORATION DISCLAIMS
  15. ; ALL WARRANTIES, EXPRESS OR IMPLIED, INCLUDING WITHOUT LIMITATION THE
  16. ; IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
  17. ; PURPOSE, AND NOTWITHSTANDING ANY OTHER PROVISION CONTAINED HEREIN, ANY
  18. ; LIABILITY FOR DAMAGES RESULTING FROM THE SOFTWARE OR ITS USE IS
  19. ; EXPRESSLY DISCLAIMED, WHETHER ARISING IN CONTRACT, TORT (INCLUDING
  20. ; NEGLIGENCE) OR STRICT LIABILITY, EVEN IF XEROX CORPORATION IS ADVISED
  21. ; OF THE POSSIBILITY OF SUCH DAMAGES.
  22. ; **********************************************************************
  23. ;
  24. ; Some simple examples of using Tiny CLOS and its MOP.
  25. ; 
  26. ; Much of this stuff corresponds to stuff in AMOP (The Art of the
  27. ; Metaobject Protocol).
  28. ;
  29.  
  30. ;***
  31. ;
  32. ; This is a useful sort of helper function.  Note how it uses the
  33. ; introspective part of the MOP.  The first few pages of chapter
  34. ; two of the AMOP discuss this.
  35. ;
  36. ; Note that this introspective MOP doesn't support back-links from
  37. ; the classes to methods and generic functions.  Is that worth adding?
  38. ;
  39. ;
  40. (define initialize-slots
  41.     (lambda (object initargs)
  42.       (let ((not-there (list 'shes-not-there)))
  43.     (for-each (lambda (slot)
  44.             (let ((name (car slot)))
  45.               (let ((value  (getl initargs name not-there)))
  46.             (if (eq? value not-there)
  47.                 'do-nothing
  48.                 (slot-set! object name value)))))
  49.           (class-slots (class-of object))))))
  50.  
  51.  
  52.  
  53. ;***
  54. ;
  55. ; A simple class, just an instance of <class>.  Note that we are using
  56. ; make and <class> rather than make-class to make it.  See Section 2.4
  57. ; of AMOP for more on this.
  58. ;
  59. ;
  60.  
  61. (define <pos> (make <class>                          ;[make-class 
  62.             'direct-supers (list <object>)   ;  (list <object>) 
  63.             'direct-slots  (list 'x 'y)))    ;  (list 'x 'y)]
  64.  
  65. (add-method initialize
  66.     (make-method (list <pos>)
  67.       (lambda (call-next-method pos initargs)
  68.     (call-next-method)
  69.     (initialize-slots pos initargs))))
  70.  
  71. (define p1 (make <pos> 'x 1 'y 2))
  72. (define p2 (make <pos> 'x 3 'y 5))
  73.  
  74.  
  75. ;***
  76. ;
  77. ; Another way of writing that class definition, that achives better
  78. ; `encapsulation' by using slot names that are unique keys, rather
  79. ; than symbols.
  80. ;
  81. ;
  82.  
  83. (define <pos>)
  84. (define pos-x (make-generic))
  85. (define pos-y (make-generic))
  86. (define move  (make-generic))
  87.  
  88. (let ((x (vector 'x))
  89.       (y (vector 'y)))
  90.   
  91.   (set! <pos> (make <class>
  92.             'direct-supers (list <object>)
  93.             'direct-slots  (list x y)))
  94.  
  95.   (add-method pos-x
  96.       (make-method (list <pos>)
  97.     (lambda (call-next-method pos) (slot-ref pos x))))
  98.   (add-method pos-y
  99.       (make-method (list <pos>)
  100.     (lambda (call-next-method pos) (slot-ref pos y))))
  101.  
  102.   (add-method move
  103.       (make-method (list <pos>)
  104.         (lambda (call-next-method pos new-x new-y)
  105.       (slot-set! pos x new-x)
  106.       (slot-set! pos y new-y))))
  107.  
  108.   (add-method initialize
  109.       (make-method (list <pos>)
  110.     (lambda (call-next-method pos initargs)
  111.       (move pos (getl initargs 'x 0) (getl initargs 'y 0)))))
  112.   )
  113.  
  114.  
  115. (define p3 (make <pos> 'x 1 'y 2))
  116. (define p4 (make <pos> 'x 3 'y 5))
  117.  
  118.  
  119. ;***
  120. ;
  121. ; Class allocated slots.
  122. ;
  123. ; In Scheme, this extension isn't worth a whole lot, but what the hell.
  124. ;
  125. ;
  126.  
  127. (define <class-slots-class>
  128.     (make-class (list <class>)
  129.         (list)))
  130.  
  131. (add-method compute-getter-and-setter
  132.     (make-method (list <class-slots-class>)
  133.       (lambda (call-next-method class slot allocator)
  134.     (if (null? (memq ':class-allocation slot))
  135.         (call-next-method)
  136.         (let ((cell '()))
  137.           (list (lambda (o) cell)
  138.             (lambda (o new) (set! cell new) new)))))))
  139.  
  140.  
  141. ;
  142. ; Here's a silly program that uses class allocated slots.
  143. ;
  144. ;
  145. (define <ship>
  146.     (make <class-slots-class>
  147.       'direct-supers (list <object>)
  148.       'direct-slots  (list 'name
  149.                    '(all-ships :class-allocation))))
  150.  
  151. (add-method initialize
  152.     (make-method (list <ship>)
  153.       (lambda (call-next-method ship initargs)
  154.     (call-next-method)
  155.     (initialize-slots ship initargs)
  156.     (slot-set! ship
  157.            'all-ships
  158.            (cons ship (slot-ref ship 'all-ships))))))
  159.  
  160. (define siblings (make-generic))
  161. (add-method siblings
  162.     (make-method (list <ship>)
  163.       (lambda (call-next-method ship)
  164.     (remove ship (slot-ref ship 'all-ships)))))
  165.  
  166. (define s1 (make <ship> 'name 's1))
  167. (define s2 (make <ship> 'name 's2))
  168. (define s3 (make <ship> 'name 's3))
  169.  
  170.  
  171.  
  172. ;***
  173. ;
  174. ; Here's a class of class that allocates some slots dynamically.
  175. ;
  176. ; It has a layered protocol (dynamic-slot?) that decides whether a given
  177. ; slot should be dynamically allocated.  This makes it easy to define a
  178. ; subclass that allocates all its slots dynamically.
  179. ;
  180. ;
  181. (define <dynamic-class>
  182.     (make-class (list <class>)
  183.         (list 'alist-g-n-s)))
  184.  
  185.  
  186. (define dynamic-slot? (make-generic))
  187.  
  188. (add-method dynamic-slot?
  189.     (make-method (list <dynamic-class>)
  190.       (lambda (call-next-method class slot)
  191.     (memq :dynamic-allocation (cdr slot)))))
  192.  
  193.  
  194.  
  195. (define alist-getter-and-setter
  196.     (lambda (dynamic-class allocator)
  197.       (let ((old (slot-ref dynamic-class 'alist-g-n-s)))
  198.     (if (null? old)
  199.         (let ((new (allocator (lambda () '()))))
  200.           (slot-set! dynamic-class 'alist-g-n-s new)
  201.           new)
  202.         old))))
  203.  
  204.  
  205. (add-method compute-getter-and-setter
  206.     (make-method (list <dynamic-class>)
  207.       (lambda (call-next-method class slot allocator)
  208.     (if (null? (dynamic-slot? class slot))
  209.         (call-next-method)
  210.         (let* ((name (car slot))
  211.            (g-n-s (alist-getter-and-setter class allocator))
  212.            (alist-getter (car g-n-s))
  213.            (alist-setter (cadr g-n-s)))
  214.           (list (lambda (o)
  215.               (let ((entry (assq name  (alist-getter o))))
  216.             (if (null? entry)
  217.                 '()
  218.                 (cdr entry))))
  219.             (lambda (o new)
  220.               (let* ((alist (alist-getter o))
  221.                  (entry (assq name alist)))
  222.             (if (null? entry)
  223.                 (alist-setter o
  224.                               (cons (cons name new) alist))
  225.                 (set-cdr! entry new))
  226.             new))))))))
  227.  
  228.  
  229. (define <all-dynamic-class>
  230.     (make-class (list <dynamic-class>)
  231.         (list)))
  232.  
  233. (add-method dynamic-slot?
  234.     (make-method (list <all-dynamic-class>)
  235.       (lambda (call-next-method class slot) #t)))
  236.         
  237.  
  238.  
  239. ;
  240. ; A silly program that uses this.
  241. ;
  242. ;
  243. (define <person> (make <all-dynamic-class>
  244.                'direct-supers (list <object>)
  245.                'direct-slots  (list 'name 'age 'address)))
  246.  
  247. (add-method initialize
  248.     (make-method (list <person>)
  249.       (lambda (call-next-method person initargs)
  250.     (initialize-slots person initargs))))
  251.  
  252.  
  253. (define person1 (make <person> 'name 'sally))
  254. (define person2 (make <person> 'name 'betty))
  255. (define person3 (make <person> 'name 'sue))
  256.  
  257.  
  258. ;***
  259. ;
  260. ; A ``database'' class that stores slots externally.
  261. ;
  262. ;
  263.  
  264. (define <db-class>
  265.   (make-class (list <class>)
  266.           (list 'id-g-n-s)))
  267.  
  268. (define id-getter-and-setter
  269.     (lambda (db-class allocator)
  270.       (let ((old (slot-ref db-class 'id-g-n-s)))
  271.     (if (null? old)
  272.         (let ((new (allocator db-allocate-id)))
  273.           (slot-set! class 'id-g-n-s new)
  274.           new)
  275.         old))))
  276.  
  277. (add-method compute-getter-and-setter
  278.     (make-method (list <db-class>)
  279.       (lambda (call-next-method class slot allocator)
  280.     (let* ((id-g-n-s (id-getter-and-setter class allocator))
  281.            (id-getter (car id-g-n-s))
  282.            (id-setter (cadr id-g-n-s))
  283.            (slot-name (car slot)))
  284.       (list (lambda (o)
  285.           (db-lookup (id-getter o) slot-name)) 
  286.         (lambda (o new)
  287.           (db-store  (id-getter o) slot-name new)))))))
  288.  
  289.  
  290. ;***
  291. ;
  292. ; A kind of generic that supports around methods.
  293. ;
  294. ;
  295. (define make-around-generic
  296.     (lambda () (make <around-generic>)))
  297.  
  298. (define make-around-method
  299.     (lambda (specializers procedure)
  300.       (make <around-method>
  301.         'specializers specializers
  302.         'procedure procedure)))
  303.  
  304.  
  305. (define <around-generic> (make <entity-class>
  306.                    'direct-supers (list <generic>)))
  307. (define <around-method>  (make <class>
  308.                    'direct-supers (list <method>)))
  309.  
  310.  
  311. (define around-method?   (make-generic))
  312.  
  313. (add-method around-method?
  314.     (make-method (list <method>)
  315.       (lambda (call-next-method x) #f)))
  316. (add-method around-method?
  317.     (make-method (list <around-method>)
  318.       (lambda (call-next-method x) #t)))
  319.  
  320.  
  321. (add-method compute-methods
  322.     (make-method (list <around-generic>)
  323.       (lambda (call-next-method generic)
  324.     (let ((normal-compute-methods (call-next-method)))
  325.       (lambda (args)
  326.         (let ((normal-methods (normal-compute-methods args)))
  327.           (append
  328.             (filter-in around-method?
  329.                normal-methods)
  330.         (filter-in (lambda (m) (not (around-method? m)))
  331.                normal-methods))))))))
  332.  
  333.  
  334. ;
  335. ; And a simple example of using it.
  336. ;
  337. ;
  338. (define <baz> (make-class (list <object>) (list)))
  339. (define <bar> (make-class (list <baz>)    (list)))
  340. (define <foo> (make-class (list <bar>)    (list)))
  341.  
  342.  
  343. (define test-around
  344.     (lambda (generic)
  345.       (add-method generic
  346.       (make-method        (list <foo>)
  347.                           (lambda (cnm x) (cons 'foo (cnm)))))
  348.  
  349.       (add-method generic
  350.       (make-around-method (list <bar>)
  351.                   (lambda (cnm x) (cons 'bar (cnm)))))
  352.  
  353.       (add-method generic
  354.       (make-method        (list <baz>)
  355.                           (lambda (cnm x) '(baz))))
  356.  
  357.       (generic (make <foo>))))
  358.  
  359.  
  360. (equal? (test-around (make-generic))        '(foo bar baz))
  361. (equal? (test-around (make-around-generic)) '(bar foo baz))
  362.